perm filename JJUST.F4[MSS,LCS] blob sn#143870 filedate 1975-02-04 generic text, type T, neo UTF8
00100		SUBROUTINE JJUST
00200		DATA RSP/.5/,RI/4.5/
00220		COMMON JY,L,RJH,RJD,RDIS
00300		COMMON/Q/ RN(20000),PWDS(2500),V(200)
00400		1,RSTFAC(120),STFF(120),R(2,1500),JR(120),P1,P2,I,M
00600	
00650		DIMENSION IR(2,1500)
00675		EQUIVALENCE (R,IR)
00700		JJB=-1
00710		IX=PWDS(I+1)-1
00800		JB=0
00900		RRT=P2
01000		RZRO=P1
01050		RJD=P1
01100		IF(RRT.EQ.0)RRT=200
01200		IF(RZRO.EQ.0)RZRO=.001
01300		JCNT=0
01400		RJSZ=RI
01500	CC	RJF=0
01600		RJK=0
01700	19	IF(JCNT.GT.9)GO TO 101
01800		ROV=RRT
01900		RJSZ=RJSZ-.2	
02000		JCNT=JCNT+1
02100	C  TEMPORARY COUNTER
02200		ML=1
02300		TYPE 111,JCNT
02350	111	FORMAT(I4)
02400	
02500		DO 11 KN=1,M*8
02600		RSPC=0
02610		MQ=MOD(KN,8)
02620		IF(MQ.EQ.0)MQ=8
02630		MQ=MQ-4
02640		RJH=MQ
02700	CC	RJH=KN
02800		N=0
02900	
03000		DO 2 K=1,I
03100		L=PWDS(K)
03200		RA=RN(L+1)
03300		RB=RN(L+2)
03400	       IF(((RN(L+3).NE.RJH.OR.JFAC(L).NE.KN/8).AND.RA.NE.4)
03405		1 .OR.RB.LT.RZRO) GO TO 2
03500		IF(RA.EQ.1)GO TO 10
03600	27	IF(RA.GT.4.AND.RA.NE.18.AND.RA.NE.7)GO TO 2
03700		IF(RA.EQ.4.AND.RN(L).GT.2)GO TO 2
03800	C  SHOULD CHECK ON BAR LINES NO MATTER WHICH STAFF
03900	10	N=N+1
04000		R(1,N)=RB
04100		IR(2,N)=L
04200		IF(N.EQ.1000)GO TO 28
04300	C  ONLY TREATS 1000 ITEMS AT A TIME.
04400	
04500	
04600	2	CONTINUE
04700	
04800		IF(N.EQ.0)GO TO 11
04900	28	KM=JFAC(L)
05000	C  SEE FUNCTION JFAC.  RSTFAC PNTR.
05100		DO 23 K=1,N
05200	23	IF(RN(IR(2,K)+1).NE.4)GO TO 24
05300	C  SKIPS IF ONLY BAR LINES ON THIS STAFF
05400		GO TO 11
05500	24	RSTJC=RSTFAC(KM*8+MQ+4)
05600	CC	N=N-1
05700		CALL SORT2(R,N)
05800	
05900	C  JUMP IF LAST IS A BAR LINE.
06000		K=0
06100		JLDGR=0
06200	     	JX=0
06300	22	K=K+1
06400	122	L=IR(2,K)
06500		RA=RN(L+1)
06600		RB=0
06700		RX=RN(L+5)
06800		RY=1
06900		RW=AMOD(RN(L+4),100.)
07000		IF(RA.GT.1)GO TO 4
07100		RZ=RN(L+7)
07200		IF(LDGR.NE.JLDGR)JLDGR=0
07300		LDGR=0
07400		JY=K
07500		DO 32 JJ=JY+1,N+1
07600		K=JJ
07700	32	IF(R(1,JJ)-R(1,JJ-1).GT.RSP)GO TO 35
07800	C  FOUND HOW MANY MEMBERS TO CHORD.
07900	35	RB=0
08000		K=K-1
08100		RQ=0
08200		RD=0
08300	125	IF(AMOD(RN(L+4),200.).GT.60.)RY=.6
08400		DO 37 JJ=JY,K-1
08500		IF(RD.NE.0)GO TO 38
08600	C FINDS ONLY HIGH OR! LOW LED. LINE.
08700		JIR=IR(2,JJ)
08800		RW=AMOD(RN(JIR+4),100.)
08900		IF(RW.LE.11.AND.RW.GE.2)GO TO 38
09000		LDGR=-1
09100		IF(RW.GT.11)LDGR=1
09200		IF(JLDGR.EQ.LDGR)GO TO 36
09300		JLDGR=LDGR
09400	C LDGR IS FOR LEDGER LINES.
09500		GO TO 38
09600	36	RD=1.5
09700		RQ=RD
09800	38	IF(RB.GT.2)GO TO 222
09900	C  JUMP IF LARGE SPACE AFTER NOTE IS ALREADY SET UP.
10000		RZZ=RN(JIR+7)
10100		RE=RN(JIR+5)
10200		IF(RB.LT.2.AND.((AMOD(RZZ,10.).NE.0.AND.RE.LT.20).
10300		1 OR.RZZ.GE.10))RB=1.5+EXTEN(RZZ)
10400	C  SPACE FOR DOT OR TAIL(IF STEM UP)
10500		IF(ABS(RN(JIR+6)).EQ.10)RB=RB+2
10600	C  FOR CHORD TONES ON RIGHT OF STEM UP.
10700	C  LOOKS THROUGH ALL NOTES OF A CHORD.
10800	222	IF(AMOD(RE,10.).EQ.0)GO TO 37 
10900	C  JUMP IF NO ACCIS.
11000	425	RD=2*RY+EXTEN(RE)
11100		IF(RQ.GT.RD)RD=RQ
11200		RQ=RD
11300	C  FUNCT. EXTEN=AMOD(X,1.)*10.
11400	37 	CONTINUE
11500		IF(RY.NE.1)RB=RB-.5*RJSZ
11600	C  MINI NOTES NEED LESS SPACE
11700	25	IF(JX.GT.0)R(2,JX)=R(2,JX)+RD*RSTJC
11800		GO TO 17
11900	4	IF(RA.NE.3)GO TO 29
12000		RB=3
12100		IF(RX.GT.100)RB=1.5
12200	C  CHECK ON SIZE NEEDED FOR CLEFS
12300	29	IF(RA.NE.4)GO TO 26
12400		RB=-RJSZ/2
12500		RD=.9
12600		GO TO 25
12700	26	IF(RA.NE.18)GO TO 30
12800		IF(RW.GT.9.OR.RX.GT.9)GO TO 31
12900	C  CHECKS FOR 2-DIGIT METERS
13000		RB=-1
13100		RD=1
13200		GO TO 25
13300	31	RB=2
13400		RD=3
13500		GO TO 25
13600	30	IF(RA.NE.7)GO TO 17
13700	CC	RB=2*(ABS(RW)-2)
13800		RB=2*(ABS(RW)-1)-2
13900		RD=2
14000		GO TO 25
14100	C  SPACES FOR CORRECT NUM OF ACCIS.
14200	17	RC=(RB+RJSZ)*RSTJC
14300	C  RJSZ=DEFAULT SIZE
14400		JX=JX+1
14500		R(2,JX)=RC
14600		R(1,JX)=R(1,K)
14700	3	IF(K.LT.N)GO TO 22
14800		RA=R(1,1)
14900		RB=R(2,1)
15000	
15100		DO 13 KX=2,JX
15200		RE=R(1,KX)
15300	C  POS. BEFORE SHIFTING
15400		IF(ABS(RE-RA).GT..5)GO TO 14
15500		IF(R(2,KX).GT.RB)GO TO 16
15600	C  SKIPS DOUBLE STOPS AND VERY CLOSE ITEMS
15700		GO TO 13
15800	CC	IF(RZZ.LE.RB)GO TO 13
15900	C  JUMP WHEN SPACE TO ADD IS SMALLER THAN WHAT'S ALREADY THERE
16000	CC	RB=RZZ-RB
16100	14	RD=RA+RB-RE
16200		IF(RD.LE.0)GO TO 16
16300	C  THERE'S ENOUGH ROOM
16400	CC	RD=RA+RB-RE+RD
16500		RJD=RE+RSPC-.001
16600		RJE=1000
16700	C  MAYBE MORE? ↑↑↑↑↑
16800		RJH=RD
16900		RJI=0
17000		RSPC=RSPC+RD
17100	C  RSPC SAVES TOTAL SPACE ADDED
17200	C  GO EXPAND IT
17300		IF(R(2,KX).NE.0)GO TO 166
17400	16	RB=R(2,KX)
17500	13	RA=RE
17600	11	CONTINUE
17700	110	IF(ROV.LE.RRT+.01)GO TO 18
17800		RJD=RZRO
17900		RJE=ROV
18000		RJH=RZRO
18100		RJI=RRT-.001
18200	C  JUSTIFYING SPACE DIMINISHES EACH TIME AROUND.
18300		ML=3
18400		IF(RJSZ.GT.4)RJSZ=4
18500		GO TO 66
18600	18	ML=4
18700		RJH=ROV
18800		RJI=RRT+2
18900	C  GOES BACK TO PICK UP DANGLING ITEMS(BEYOND RRT)
19000		RJD=ROV
19100		RJE=500
19200	166	JJB=-1
19300		JB=0
19400	66	JY=1
19500		L=JY
19600		IF(RJI.NE.0)RDIS=(RJI-RJH)/(RJE-RJD)
19700	
19800	6551	RB=RN(JY)
19900		JB=JB+1
20000	CC	IF(RN(JY+3.NE. )GO TO 7551
20100	C  IF STAFF#>4, ALL STAVES ARE MOVED.
20200		RA=RN(JY+1)
20300	CC	IF(RJF.GT.0.AND.RJF.NE.RA)GO TO 7551
20400	C SKIPS IF NOT SPECIAL CODE NUM.
20500		RN2=RN(JY+2)
20600		IF(RN2.GT.RJE)GO TO 7551
20700		RC=-1
20800		RD=0
20900		IF(RA.EQ.8.OR.RA.EQ.9.OR.RA.EQ.20)RD=-1
21000		IF(RA.EQ.4..OR.RD.OR.RN(JY+5).EQ.50)RC=0
21100	C RC=0 FOR CODES 4,8,9
21200		RN6=RN(JY+6)
21300		IF(RN2.GE.RJD)GO TO 9551
21400	      IF(RC.OR.(RC.EQ.0.AND.(RN6.LE.RJD.OR.RN6.GE.RJE)))GO TO 7551
21500	C RIGHT SIDE IS BEFORE OR AFTER MOVE AREA.
21600	9551	IF(JJB)JJB=JB
21700	C   (50=CRESC., DECRESC.)
21800		RQ6=RN6-RJE
21900		RX=0
22000		RV=0
22100		IF(RA.NE.9.OR.RB.LT.7)GO TO 21
22200		RX=RN(L+9)
22300		RY=RX-RJE
22400		RZ=RJD-RX
22500		IF(RN(L+10).LT.30)GO TO 221
22600		RW=RN(L+8)
22700		IF(RW.GE.RJD.AND.RW.LE.RJE)RV=-1
22800	221	IF(RY.AND.RZ)RX=-1
22900	C PARTIAL BEAM IS WITHIN MOVE AREA.
23000	21	IF(RJI.EQ.0)GO TO 2551
23100		IF(RN2.GE.RJD)CALL MVBX(RN,2)
23200		IF(RC)GO TO 7552
23300		IF(RA.EQ.4..AND.RB.LT.4)GO TO 7552
23400		IF(RQ6)CALL MVBX(RN,6)
23500	C  END POINT OUTSIDE OF MOVE RANGE NOT AFFECTED.
23600		IF(RA.NE.9)GO TO 7552
23700		IF(RX)CALL MVBX(RN,9)
23800		IF(RV)CALL MVBX(RN,8)
23900	C  ONLY TRUE WHEN RA=9
24000		GO TO 7552
24100	
24200	2551	IF(RN2.GE.RJD)RN2=RN2+RJH
24300		RN(L+2)=RN2
24400	      IF(RQ6.AND.(RD.OR.(RA.EQ.4.AND.RB.GT.3.)))RN(L+6)=RN(JY+6)+RJH
24500		IF(RX)CALL MVBEAM(RN,9,JY,L,RJH)
24600		IF(RV)CALL MVBEAM(RN,8,JY,L,RJH)
24700		IF(RN2.GT.ROV)ROV=RN2
24800	C ??? NOT YET FIXED FOR ENDS OF SLURS OR LINES
24900	7552	L=RB+3+L
25000		IF(RJK.EQ.0)GO TO 7551
25100	1551	IF((RB.LT.3..AND.RA.NE.6.AND.RA.NE.11).OR.RA.EQ.18.OR.
25200		1 RA.EQ.10)GO TO 7551
25300	C  'U-D' SKIPS METER, STAFF, KEY SIG., ETC.
25400		JX=JY
25500		CALL MVBEAM(RN,4,JX,JX,RJK)
25600		IF(RC.EQ.0)CALL MVBEAM(RN,5,JX,JX,RJK)
25700	7551	JY=RB+3+JY
25750		L=JY
25800		IF(JY.LT.IX)GO TO 6551
25900		GO TO (16,16,19,101),ML
26000	C ↑↑↑↑↑↑????
26100	101	JJB=1
26200		END
26300		
26400	C  THESE MOVE ENDS OF PARTIAL INNER BEAMS.
26500		SUBROUTINE MVBEAM(R,I,JY,L,W)
26600	C  L AND JY ARE FOR MOVES TO DIFF. STAFF.
26700		DIMENSION R(1)
26800		Y=R(JY+I)
26900		Z=ABS(Y)
27000		IF(Z.LT.100.)GO TO 1
27100	C  NEXT FOR MINIS, DIAMONDS, 'X' NOTES. (LIMIT OF +-99 ON ALTITUDE.)
27200		Y=AMOD(Y,100.)
27300		X=Y+W
27400		Z=Z-ABS(Y)+ABS(X)
27500	C  PUTS ALL INTO POSITIVE
27600		IF(X)Z=-Z
27700		GO TO 2
27800	1	Z=Y+W
27900	2	R(L+I)=Z
28000		END
28100	
28200		SUBROUTINE MVBX(R,I)
28300		COMMON JY,L,RJH,RJD,RDIS
28400		DIMENSION R(1)
28500		R(L+I)=RJH+(R(JY+I)-RJD)*RDIS
28600		END
28700	
28800		SUBROUTINE EXCH(X,Y)
28900		Z=X
29000		X=Y
29100		Y=Z
29200		END
29300		SUBROUTINE SORT2(RPOS,M)
29400		DIMENSION RPOS(2,1000)
29500		L=2
29600	3	J=-1
29700		RX=RPOS(1,L-1)
29800		DO 2 K=L,M
29900		IF(RPOS(1,K).GE.RX)GO TO 2
30000		RX=RPOS(1,K)
30100	C   WHY WERE ALL THE RX'S  JX ????? 9/6/73
30200		J=K
30300	2	CONTINUE
30400		IF(J)GO TO 4
30500		K=L-1
30600		CALL EXCH(RPOS(1,K),RPOS(1,J))
30700		CALL EXCH(RPOS(2,K),RPOS(2,J))
30800	4	L=L+1
30900		IF(L.LE.M)GO TO 3
31000		END
31100	
31200		FUNCTION EXTEN(X)
31300		EXTEN=AMOD(X,1.)*10.
31400		END
31500	
31600		FUNCTION JFAC(L)
31700	C  FINDS RSTFAC POINTER
31800	CC	COMMON /RS/JW(80)
31810		COMMON/Q/ RN(20000),PWDS(2500),V(200)
31855		1,RSTFAC(120),STFF(120),R(2,1500),JR(120),P1,P2,I,M
31900		K=0
32000	CC	R=L
32100	1	K=K+1
32200		IF(L.GE.JR(K))GO TO 1
32300		JFAC=K-2
32400		END